home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-lalr1.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  11.1 KB  |  289 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ------------------------------------------------- ;
  2. ; File:         zebu-lalr1.l
  3. ; Description:  Calculation of LALR(1) sets
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      31-Oct-90
  6. ; Modified:     Thu Jan 28 12:17:27 1993 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;;             Copyright (C) 1989, by William M. Wells III
  18. ;;;                         All Rights Reserved
  19. ;;;     Permission is granted for unrestricted non-commercial use.
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. (in-package "ZEBU")
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;;                             Propagate lookaheads
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. ;;; This is used when we discover that lookaheads propagate from one
  29. ;;; lr(0) item set to another during the calculation of lalr(1) sets
  30. ;;; of items.  Add a link to the dependency digraph and propagate the
  31. ;;; lookaheads we already know about.
  32.  
  33. (declaim (inline lalr1-add-depender lalr1-add-lookahead))
  34.  
  35. ;;; This is used when we discover a lookhead for an lr(0) item set during
  36. ;;; the calculation of lalr(1) sets.  If the lookahead wasn't already there,
  37. ;;; add it, and also add it to the "dependers": those item sets to whom
  38. ;;; lookaheads propagate from the item in question.
  39.  
  40. (defun lalr1-add-lookahead (symbol item)
  41.   (declare (type item item))
  42.   (labels ((lalr1-add-lookahead-aux (item)
  43.          (when (oset-insert! symbol (item-look-aheads item))
  44.            ;; Wasn't already there.
  45.            (dolist (depender
  46.              (the list (oset-item-list
  47.                     (the oset
  48.                      (item-look-ahead-dependers item)))))
  49.          (lalr1-add-lookahead-aux depender)))))
  50.     (lalr1-add-lookahead-aux item)))
  51.  
  52. (defun lalr1-add-depender (propagate-to propagate-from)
  53.   (if (oset-insert! propagate-to (item-look-ahead-dependers propagate-from))
  54.       (dolist (gs (the list (oset-item-list
  55.                  (the oset (item-look-aheads propagate-from)))))
  56.     (lalr1-add-lookahead gs propagate-to))))
  57.  
  58.  
  59. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60. ;;; Discover and propagate lalr(1) look-aheads among members of lr(0)
  61. ;;; collection.
  62.  
  63. ;;; This algorithm for propagating lalr(1) lookaheads is a straightforward
  64. ;;; recursive version of the algorithm sketched in section 6.9 of the (older)
  65. ;;; dragon book "Principles of Compiler Design" by A.V. Aho and J.D Ullman.
  66. ;;; The major drawback of this algorithm is that it may be somewhat wasteful
  67. ;;; of space.  With modern address spaces who cares?
  68. ;;; Basically, it crawls around on the lr(0) item sets and as it goes,
  69. ;;; it discovers both lookaheads which are "spontaneously" generated for
  70. ;;; an item set, and item sets to whom lookaheads propagate.  The doubly
  71. ;;; recursive way of implementing this is similar to the method used
  72. ;;; in calculating first sets in first.l
  73.  
  74. ;;; (New) the names are getting a bit confusing here.  This function transforms
  75. ;;; the data structure *lr0-item-sets* from being the lr(0) collection to
  76. ;;; the lalr(1) collection.
  77.  
  78. ;; the following is heavily optimized in the inner loop, and therefore hardly 
  79. ;; intelligible.  For reference look at the original Scheme program at the
  80. ;; end of this file.
  81.  
  82. (declaim (special *LR0-START-STATE-INDEX*))
  83.  
  84. (defun lalr1-do-lookaheads ()
  85.   ;; Introduce a "dummy" terminal symbol which is used as a hack in
  86.   ;; lookahead calculations.
  87.   (let ((dummy-g-symbol (new-g-symbol "dummy" -1))
  88.     (lr0-item-sets-item-list (oset-item-list (the oset *lr0-item-sets*)))
  89.     (sad-list (list nil)))        ; efficiency hack
  90.     ;; The dummy symbol is terminal and must be in its own first set.
  91.     (oset-insert! dummy-g-symbol (g-symbol-first-set dummy-g-symbol))
  92.     ;; Map over all the kernel items.
  93.     (dolist (item-set lr0-item-sets-item-list)
  94.       (declare (type item-set item-set))
  95.       (let* ((kernel (item-set-kernel item-set))
  96.          (index (item-set-index item-set))
  97.          (item-set-goto-map (item-set-goto-map item-set))
  98.          (goto-map-odf (oset-order-fn item-set-goto-map))
  99.          (goto-map-item-list (oset-item-list item-set-goto-map)))
  100.     (declare (fixnum index))
  101.     (dolist (kernel-item (the list (oset-item-list (the oset kernel))))
  102.       ;; Special case: the end symbol is a lookahead for the start
  103.       ;; production.
  104.       (if (= *lr0-start-state-index* index)
  105.           ;; There had better only be one item in this set!
  106.           (lalr1-add-lookahead *the-end-g-symbol* kernel-item))
  107.       ;; Here we use the hack in dragon 6.9 (fig 6.20) of using lr(1)
  108.       ;; closure with a dummy grammar symbol to discover propagated
  109.       ;; and spontaneous lookaheads for a lr(0) kernel item.  The
  110.       ;; funny-closure-items are in J' of the figure.
  111.       (dolist (funny-closure-item
  112.             ;; The set of "funny" closure items. J'.
  113.             (the list (oset-item-list
  114.                    (the oset (single-item-closure-1
  115.                       (copy-lr0-item kernel-item)
  116.                       dummy-g-symbol)))))
  117.         (declare (type item funny-closure-item))
  118.         (block funny-closure-item
  119.           (let ((funny-closure-item-look-aheads
  120.              (item-look-aheads funny-closure-item)))
  121.         (when (oset-empty? funny-closure-item-look-aheads)
  122.           (return-from funny-closure-item nil))
  123.         (let* ((production (item-production funny-closure-item))
  124.                (production-length (production-length production))
  125.                (item-after-dot (item-after-dot funny-closure-item)))
  126.           (declare (fixnum production-length item-after-dot)
  127.                (type production production))
  128.           (when (= production-length item-after-dot)
  129.               (return-from funny-closure-item nil))
  130.           (let* ((goto-item-proto (make-item
  131.                        :production production
  132.                        :after-dot (1+ item-after-dot)))
  133.              (set (item-set-kernel
  134.                    (cdr (or (progn
  135.                       ;; instead of CONSing we reuse SAD-LIST
  136.                       (setf (car (the CONS sad-list))
  137.                         (nth item-after-dot
  138.                              (the list (rhs production))))
  139.                       (dolist (item goto-map-item-list)
  140.                         (when (eq 'equal
  141.                               (funcall goto-map-odf
  142.                                    sad-list item))
  143.                           (return item))))
  144.                     (error "Failed to find the goto set")))))
  145.              (odf (oset-order-fn set))
  146.              ;; Here we go to some expense to locate the goto set
  147.              ;; for an item.
  148.              ;; These should be pre-computed and cached instead.
  149.              (goto-item
  150.               (dolist (item (oset-item-list set)
  151.                    (error "Failed to find goto item"))
  152.                 (when (eq 'equal
  153.                       (funcall odf goto-item-proto item))
  154.                   (return item)))))
  155.             (dolist (lookahead
  156.                   (oset-item-list
  157.                    (the oset funny-closure-item-look-aheads)))
  158.               (if (eq lookahead dummy-g-symbol)
  159.               ;; Discovered lookahead propagation.
  160.               (lalr1-add-depender goto-item kernel-item)
  161.             ;; Discovered lookahead.
  162.             (lalr1-add-lookahead lookahead goto-item))))))))))
  163.       (princ "."))
  164.     ;; NEW STUFF HERE: 1-27-88
  165.     (terpri)
  166.     (dolist (item-set lr0-item-sets-item-list)
  167.       (declare (type item-set item-set))
  168.       (closure-1! (item-set-closure item-set))
  169.       (princ "."))))
  170.  
  171.  
  172. ;;; This should be primitive, and not insert if not there.
  173. ;;; Third arg is error msg
  174. ;;; result is eq to member of the set.
  175.  
  176. (defun oset-find (element set)
  177.   (let ((odf (oset-order-fn set)))
  178.     (dolist (item (oset-item-list set))
  179.       (when (eq 'equal (funcall odf element item))
  180.     (return item)))))
  181.  
  182. (defun copy-lr0-item (i)
  183.   (make-item :production (item-production i)
  184.              :after-dot (item-after-dot i)))
  185.  
  186. ;;;    Do all needed to generate parse tables starting with a lisp syntax
  187. ;;;    grammar. (doesn't write out a table file)
  188.  
  189. (defun lalr1-tables-from-grammar (file-name)
  190.   (load-grammar file-name)
  191.   (calculate-empty-string-derivers)
  192.   (calculate-first-sets)
  193.   (calculate-follow-sets)
  194.   (make-lr0-collection)
  195.   (lalr1-do-lookaheads)
  196.   (build-parse-tables t)
  197.   file-name)
  198.  
  199. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  200. ;;                          Original Scheme Algorithm
  201. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  202. #||
  203. (define (lalr1-do-lookaheads)
  204.     ;; Introduce a "dummy" terminal symbol which is used as a hack in
  205.     ;; lookahead calculations.
  206.     (let ((dummy-g-symbol (new-g-symbol "dummy" -1)))
  207.       ;; The dummy symbol is terminal and must be in its own first set.
  208.       (oset-insert! dummy-g-symbol (g-symbol-first-set dummy-g-symbol))
  209.       ;; Map over all the kernel items.
  210.       (oset-for-each
  211.        (lambda (item-set)
  212.      (oset-for-each
  213.       (lambda (kernel-item)
  214.         ;; Special case: the end symbol is a lookahead for the start
  215.         ;; production.
  216.         (if (equal? lr0-start-state-index (item-set-index item-set))
  217.         ;; There had better only be one item in this set!
  218.         (lalr1-add-lookahead the-end-g-symbol kernel-item))
  219.  
  220.         ;; Here we use the hack in dragon 6.9 (fig 6.20) of using lr(1)
  221.         ;; closure with a dummy grammar symbol to discover propagated
  222.         ;; and spontaneous lookaheads for a lr(0) kernel item.  The
  223.         ;; funny-closure-items are in J' of the figure.
  224.  
  225.         (oset-for-each
  226.          (lambda (funny-closure-item)
  227.            (if 
  228.            (not (oset-empty? (item-look-aheads funny-closure-item)))
  229.            (begin
  230.             (let ((goto-item-proto (advance-dot funny-closure-item)))
  231.               (if goto-item-proto
  232.               (begin
  233.                ;; Here we go to some expense to locate the goto set
  234.                ;; for an item.
  235.                ;; These should be pre-computed and cached instead.
  236.                (let ((goto-item
  237.                   (oset-find
  238.                    goto-item-proto
  239.                    (item-set-kernel
  240.                     (find-goto-set
  241.                      item-set
  242.                      (symbol-after-dot funny-closure-item)))
  243.                    "internal error - failed to find goto item")))
  244.                  (oset-for-each
  245.                   (lambda (lookahead)
  246.                 (if (eq? lookahead dummy-g-symbol)
  247.                     ;; Discovered lookahead propagation.
  248.                     (lalr1-add-depender goto-item kernel-item)
  249.                   ;; Discovered lookahead.
  250.                   (lalr1-add-lookahead lookahead goto-item)))
  251.                   (item-look-aheads funny-closure-item)))))))))
  252.          ;; The set of "funny" closure items. J'.
  253.          (single-item-closure-1 (copy-lr0-item kernel-item)
  254.                     dummy-g-symbol)))
  255.       (item-set-kernel item-set))
  256.      (display "."))
  257.        lr0-item-sets))
  258.  
  259.   ;; NEW STUFF HERE: 1-27-88
  260.   (newline)
  261.   (oset-for-each
  262.    (lambda (item-set)
  263.      (closure-1! (item-set-closure item-set))
  264.      (display "."))
  265.    lr0-item-sets
  266.    ))
  267. ||#
  268. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  269. ;;; test
  270. #||
  271. (set-working-direct *ZEBU-test-directory*)
  272. (lalr1-tables-from-grammar "ex6_2.zb")
  273.  
  274. (progn
  275.   (lalr1-tables-from-grammar "ex4.zb")
  276.   (princ "symbols: ") (terpri)
  277.   (cruise-symbols-2)
  278.   (princ "productions: ") (terpri)
  279.   (print-productions)
  280.   (princ "lr0 item sets: ") (terpri)
  281.   (print-collection nil)
  282.   (princ "lalr(1) tables: ") (terpri)
  283.   (cruise-parse-tables)
  284.   )
  285. ||#
  286. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  287. ;;                               End of zebu-lalr1.l
  288. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  289.